home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / type / type-main.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  2.8 KB  |  78 lines  |  [TEXT/CCL2]
  1.  
  2. ;;; This is the main entry point to the type checker.
  3.  
  4.  
  5. (define (do-haskell-type-check object modules)
  6.   (type-init modules)
  7.   (attach-interface-signatures modules)
  8.   (when (is-type? 'let object) ; may be void
  9.     (dynamic-let ((*non-generic-tyvars* '())
  10.           (*placeholders* '())
  11.           (*enclosing-decls* '()))
  12.       (type-check/decls let decls
  13.      (setf (dynamic *non-generic-tyvars*) '())
  14.          (process-placeholders (dynamic *placeholders*) '() '()))))
  15.   'done)
  16.  
  17. ;;; This is the main recursive entry to the type checker.
  18.  
  19. (define (dispatch-type-check exp)
  20.  (remember-context exp
  21.   (call-walker type exp)))
  22.  
  23. (define (do-type-check/list exps)
  24.   (if (null? exps)
  25.       (values '() '())
  26.       (mlet (((obj1 type1) (dispatch-type-check (car exps)))
  27.          ((objs types) (do-type-check/list (cdr exps))))
  28.     (values (cons obj1 objs) (cons type1 types)))))
  29.  
  30. (define (type-init modules)
  31.   ;; Built in types
  32.   (setf *char-type* (**ntycon (core-symbol "Char") '()))
  33.   (setf *string-type* (**ntycon (core-symbol "List")
  34.                 (list *char-type*)))
  35.   (setf *bool-type* (**ntycon (core-symbol "Bool") '()))
  36.   (setf *int-type* (**ntycon (core-symbol "Int") '()))
  37.   (setf *integer-type* (**ntycon (core-symbol "Integer") '()))
  38.   (setf *rational-type* (**ntycon (core-symbol "Ratio")
  39.                   (list *integer-type*)))
  40.   (setf *dynamic-type* (**ntycon (core-symbol "Dynamic") '()))
  41.   (setf *signature-type* (**ntycon (core-symbol "Signature") '()))
  42.   (setf *magic-type* (**ntycon (core-symbol "Magic") '()))
  43.   (setf *default-decls* '())
  44.   (dolist (m modules)
  45.     (let ((default-types '()))
  46.       (dolist (d (default-decl-types (module-default m)))
  47.         (let* ((ty (ast->gtype '() d))
  48.            (ntype (gtype-type ty)))
  49.       (cond ((not (null? (gtype-context ty)))
  50.          (recoverable-error 'not-monotype
  51.            "~A is not a monotype in default decl" ty))
  52.         ((not (type-in-class? ntype (core-symbol "Num")))
  53.          (recoverable-error 'not-Num-class
  54.            "~A is not in class Num" ty))
  55.         (else
  56.          (push ntype default-types)))))
  57.       (push (tuple (module-name m) (reverse default-types)) *default-decls*))))
  58.  
  59. (define (remember-placeholder placeholder)
  60.   (push placeholder (dynamic *placeholders*)))
  61.  
  62. ;;; This is for interface files.
  63.  
  64. ;;; When an interface file supplies a type signature for a var,
  65. ;;; this signature is either attached to the var if no local signature is
  66. ;;; supplied or compared to the implementation signature.
  67.  
  68. (define (attach-interface-signatures mods)
  69.   (let ((mod-names (map (function module-name) mods)))
  70.     (dolist (mod (get-all-interfaces))
  71.       (dolist (alist (module-interface-definitions mod))
  72.         (when (memq (car alist) mod-names)
  73.       (let ((st (module-symbol-table (locate-module (car alist)))))
  74.         (dolist (idef (cdr alist))
  75.           (let ((def (table-entry st (def-name idef))))
  76.         (when (and def (var? def) (not (var-signature def)))
  77.            (setf (var-signature def) (var-signature idef)))))))))))
  78.